home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / dump.t < prev    next >
Text File  |  1988-05-02  |  11KB  |  286 lines
  1. (herald dump
  2.   (env tsys (osys dump_codes)))
  3.  
  4. ;;; A T-object dumper.  Li Kai's algorithm implemented by Richard
  5. ;;; Kelsey, modified for T3 by David Kranz
  6.  
  7. ;;; Generation number.  This must be negative to avoid conflict with the first
  8. ;;; dumper which didn't have a generation number.
  9.  
  10. (define dump-magic-number -1)
  11.  
  12. (define-predicate dump-port?)
  13. (define-operation (set-encoder self encoder))
  14.  
  15. ;;;   Returns a port that handles the operations WRITE and CLOSE.
  16. ;;; The idea is to make a dump file look like any other to the user.
  17. ;;; Dumped objects are written into a vector.  When the dump port is closed
  18. ;;; the objects are written into the file.
  19.  
  20. (define (default-dump-encoder x)  ; back end bug
  21.   (ignore x)
  22.   (return nil nil nil))
  23.  
  24. (define (maybe-open-dump-file filename)
  25.   (let ((things    (make-infinite-vector 60 false 'dump-vector))
  26.         (status    (make-dump-status))
  27.         (delimits  '())
  28.         (encoder   default-dump-encoder)
  29.         (objects   (make-table 'dumped-objects)))
  30.     (object nil
  31.       ((write self thing)
  32.        (push delimits (dump-status-count status))
  33.        (vectorize thing things status objects encoder)
  34.        '#t)
  35.       ((close self)
  36.        (dump filename things status objects (reverse! (cons -1 delimits)))
  37.        (recycle things)
  38.        (recycle objects)
  39.        '#t)
  40.       ((set-encoder self e)
  41.        (set encoder e))
  42.       ((dump-port? self) '#t)
  43.       ((port? self) '#t)
  44.       ((print-info self) filename)
  45.       ((print-type-string self) "Dump-port"))))
  46.  
  47. ;;; Open a port on the file and write everything into it.  The first four
  48. ;;; bytes in the file are the generation number.  Then comes the number of
  49. ;;; duplicated objects.  Small objects are dumped in their own way.  Other
  50. ;;; objects are looked up in the OBJECTS table.  A table entry of 'ONE means
  51. ;;; that there is only one copy of the object and it can just be dumped.
  52. ;;; 'MANY means that this is the first of multiple copies.  The object
  53. ;;; is dumped with the 'shared' bit set and the table entry is set
  54. ;;; to the next duplicated object index.  Any other entry is an index which
  55. ;;; is dumped with the OBJECT-REF type.
  56.  
  57. (define (dump filename things status objects delimits)
  58.   (with-open-ports ((port (open filename 'out)))
  59.     (dump-port port things status objects delimits)))
  60.  
  61. (define (dump-port port things status objects delimits)
  62.   (let ((count (dump-status-count status))
  63.         (duplicates 0))
  64.     (dump-bytes port dump-magic-number 4)
  65.     (dump-bytes port (dump-status-duplicates status) 4)
  66.     (do ((i 0 (fx+ i 1)))
  67.         ((fx>= i count)
  68.          (dump-byte port dump/end-of-file)
  69.          (if (fxn= duplicates (dump-status-duplicates status))
  70.              (error "dump's duplicate counts didn't match")))
  71.       (let ((thing (things i)))
  72.         (cond ((fx= i (car delimits))
  73.                (dump-byte port dump/begin-object)
  74.                (pop delimits)))
  75.         (if (small-object? thing)
  76.             (dump-small-object thing port)
  77.             (let ((tag (table-entry objects thing)))
  78.               (cond ((eq? tag 'one)
  79.                      (dump-data port thing nil))
  80.                     ((eq? tag 'many)
  81.                      (set (table-entry objects thing) duplicates)
  82.                      (set duplicates (fx+ duplicates 1))
  83.                      (dump-data port thing t))
  84.                     ((fixnum? tag)
  85.                      (dump-unshared-code&size port dump/object-ref tag))
  86.                     (else 
  87.                      (error "funny dumped object tag ~S for ~S"
  88.                             tag thing)))))))))
  89.  
  90. ;;; A structure to hold the two counts associated with a dump port.  This is
  91. ;;; just a two place locative.
  92.  
  93. (define-structure-type dump-status
  94.   count
  95.   duplicates
  96.   )
  97.  
  98. (let ((m (stype-master dump-status-stype)))
  99.   (set (dump-status-count      m) 0)
  100.   (set (dump-status-duplicates m) 0))
  101.  
  102. ;;; Write THING into the infinite vector THINGS.  THING is walked recursively
  103. ;;; with each pointer being given a seperate slot in the vector.  Each pointer
  104. ;;; is looked up in the OBJECTS table to see if it has been encountered before.
  105. ;;; If it hasn't it is added to the table and any pointers it has are dealt
  106. ;;; with.
  107.  
  108. (define (vectorize thing things status objects encoder)
  109.   (iterate label ((thing thing))
  110.     (set (things (dump-status-count status)) thing)
  111.     (modify (dump-status-count status)
  112.             (lambda (x) (fx+ x 1)))
  113.     (cond ((small-object? thing))
  114.           ((table-entry objects thing)
  115.            => (lambda (flag)
  116.                 (cond ((neq? flag 'many)
  117.                        (modify (dump-status-duplicates status)
  118.                                (lambda (x) (fx+ x 1)))
  119.                        (set (table-entry objects thing) 'many)))))
  120.           (else
  121.            (set (table-entry objects thing) 'one)
  122.            (cond ((pair? thing)
  123.                   (label (car thing))
  124.                   (label (cdr thing)))
  125.                  ((vector? thing)
  126.                   (do ((i 0 (fx+ 1 i)))
  127.                       ((fx>= i (vector-length thing)))
  128.                       (label (vref thing i))))
  129.                  ((or (symbol? thing)
  130.                       (bytev? thing)
  131.                       (float? thing)
  132.                       (bignum? thing)
  133.                       (string? thing)))
  134.                  (else
  135.                   (receive (key data accessors)
  136.                            (encoder thing)
  137.                     (cond ((not key)
  138.                            (label (error '"don't know how to dump ~S" thing)))
  139.                           (else
  140.                            (label key)
  141.                            (do ((d data (cdr d))
  142.                                 (l '() (cons ((car d) thing) l)))
  143.                                ((null-list? d)
  144.                                 (label (reverse! l))))
  145.                                 (label (length accessors))
  146.                                 (iterate loop ((l accessors))
  147.                                   (cond ((null-list? l) (return))
  148.                                         (else
  149.                                          (label ((car l) thing))
  150.                                          (loop (cdr l))))))))))))))
  151. ;                                (walk (lambda (proc) ; Compiler bug
  152. ;                                        (label (proc thing)))
  153. ;                                      accessors)
  154.  
  155.  
  156. ;;; The immediate types of object.
  157.  
  158. (define (small-object? thing)
  159.   (or (null? thing)
  160.       (fixnum? thing)
  161.       (char? thing)
  162.       (eq? thing '#t)))
  163.  
  164. (define (dump-small-object thing out)
  165.   (cond ((null? thing)
  166.          (dump-byte out dump/null))
  167.         ((char? thing)
  168.          (dump-byte out dump/char)
  169.          (dump-byte out (char->ascii thing)))
  170.         ((eq? thing '#t)
  171.          (dump-byte out dump/true))
  172.         ((not (fixnum? thing))
  173.          (error "dump internal error, ~S is not a small object" thing))
  174.         ((fx<= 0 thing)
  175.          (dump-unshared-code&size out dump/positive-fixnum thing))
  176.         ((fx= thing most-negative-fixnum)   ; no corresponding positive fixnum
  177.          (dump-byte out (fx+ 3 dump/positive-fixnum)) ; four byte positive fix
  178.          (dump-bytes out thing 4))
  179.         (else
  180.          (dump-unshared-code&size out dump/negative-fixnum (fx- 0 thing)))))
  181.  
  182. ;;; Dump whatever non-pointer data an object may have.
  183.  
  184. (define (dump-data out thing shared)
  185.   (cond ((symbol? thing)
  186.          (dump-code&size out dump/symbol shared (symbol-print-length thing))
  187.          (do ((i %%symbol-text-offset (fx+ i 1)))
  188.              ((fx>= i (symbol-length thing)))
  189.            (writec out (symbol-elt thing i))))
  190.         ((pair? thing)
  191.          (dump-code out dump/pair shared))
  192.         ((vector? thing)
  193.          (dump-code&size out dump/vector shared (vector-length thing)))
  194.         ((string? thing)
  195.          (dump-code&size out dump/string shared (string-length thing))
  196.          (writes out thing))
  197.         ((bytev? thing)
  198.          (dump-code&size out dump/byte-vector shared (bytev-length thing))
  199.          (do ((i 0 (fx+ i 1)))
  200.              ((fx>= i (bytev-length thing)))
  201.            (vm-write-byte out (bref-8 thing i))))
  202.         ((bignum? thing)
  203.          (let ((code (if (> 0 thing)
  204.                          dump/negative-bignum
  205.                          dump/positive-bignum))
  206.                (length (bignum-length thing)))
  207.            (dump-code&size out code shared length)
  208.            (do ((i 0 (fx+ i 1)))
  209.                ((fx>= i length))
  210.              (dump-bytes out (bignum-digit thing i) 4))))
  211.         ((double-float? thing)
  212.          (dump-double-flonum out thing shared))
  213.         (else
  214.          (dump-code out dump/coded shared))))
  215.  
  216. (define (dump-double-flonum out flonum shared)
  217.   (receive (sign m e)
  218.            (integer-decode-float flonum)
  219.     (cond ((fixnum? m)
  220.            (dump-code&size out dump/double-flonum shared 0)
  221.            (dump-byte out (if (eq? sign 1) 1 0))
  222.            (dump-bytes out e 4)
  223.            (dump-bytes out m 4))
  224.           ((bignum? m)
  225.            (let ((length (bignum-length m)))
  226.              (dump-code&size out dump/double-flonum shared length)
  227.              (dump-byte out sign)
  228.              (dump-bytes out e 4)
  229.              (do ((i 0 (fx+ i 1)))
  230.                  ((fx>= i length))
  231.                (dump-bytes out (bignum-digit m i) 4))))
  232.           (else
  233.            (vm-error 'dump "flonum decomposed oddly ~S" flonum)))))
  234.  
  235. ;;; Write out a code that has no size field.
  236.  
  237. (define (dump-code out code shared)
  238.   (dump-byte out (if shared (fx+ 1 code) code)))
  239.  
  240. ;;; Write a code that has a size but no 'shared' field.
  241.  
  242. (define (dump-unshared-code&size out code num)
  243.   (cond ((fx< num 0)
  244.          (error "dump internal error, can't encode negative fixnum ~S" num))
  245.         ((fx< num 256)
  246.          (dump-byte out code)
  247.          (dump-byte out num))
  248.         ((fx< num 65536)
  249.          (dump-byte out (fx+ 1 code))
  250.          (dump-bytes out num 2))
  251.         ((fx< num 16777216)
  252.          (dump-byte out (fx+ 2 code))
  253.          (dump-bytes out num 3))
  254.         (else                           ; Should check here.
  255.          (dump-byte out (fx+ 3 code))
  256.          (dump-bytes out num 4))))
  257.  
  258. ;;; Write a code that both size and 'shared' fields.
  259.  
  260. (define (dump-code&size out code shared num)
  261.   (let ((code (if shared (fx+ 1 code) code)))
  262.     (cond ((fx< num 0)
  263.            (error "dump internal error, can't encode negative fixnum ~S" num))
  264.           ((fx< num 256)
  265.            (dump-byte out code)
  266.            (dump-byte out num))
  267.           ((fx< num 65536)
  268.            (dump-byte out (fx+ 2 code))
  269.            (dump-bytes out num 2))
  270.           ((fx< num 16777216)
  271.            (dump-byte out (fx+ 4 code))
  272.            (dump-bytes out num 3))
  273.           (else                           ; Should check here.
  274.            (dump-byte out (fx+ 6 code))
  275.            (dump-bytes out num 4)))))
  276.  
  277. ;;; Write out various numbers of bytes.
  278.  
  279. (define (dump-byte out byte)
  280.   (writec out (ascii->char (fixnum-logand byte #xFF))))
  281.  
  282. (define (dump-bytes out num count)
  283.   (do ((i 0 (fx+ 8 i)))
  284.       ((fx>= i (fx* count 8)))
  285.     (dump-byte out (fixnum-ashr num i))))
  286.